home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Software Vault: The Gold Collection
/
Software Vault - The Gold Collection (American Databankers) (1993).ISO
/
cdr31
/
a2z16.zip
/
A2Z.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1993-05-01
|
43KB
|
1,331 lines
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
{$M 32767,32767,32767}
program A2Z;
{
Version 1.6
This version represents minor changes in code structure. It will also be
the last version released, unless some fatal flaw is uncovered. Enjoy.
Ian McLean 404 428 7829 (voice)
3365 Timber Lake Road
Kennesaw, GA
30144
}
uses DOS, CRT;
const
MaxDirEnteries= 20; { Maximum number of directories that can be specified to search }
{ This doesn't include those searched "below" ones specified. }
DataNext: string[10]= 'CONFIGNEXT';
PKZIP: PathStr= 'U:\PKZIP.EXE'; { 80 bytes }
PKUNZIP: PathStr= 'U:\PKUNZIP.EXE'; { 80 bytes }
PKUNPAK: PathStr= 'U:\PKXARC.EXE'; { 80 bytes }
PAK: PathStr= 'U:\PAK.EXE'; { 80 bytes }
ASCIILevel: char= '4'; { 1 byte }
BinaryLevel: char= '2'; { 1 byte }
{ --------- }
{ 322 bytes }
type
FullNameStr= string[12]; { Type for storing name+dot+extention }
DirSearchEntry= record { This data type is used to store all the paths that will be searched }
Dir: DirStr; { <-- Path to search }
Name: FullNameStr; { <-- File spec to search }
Below: boolean; { <-- TRUE=search directories below the specified one }
end;
var
Dir: array[1..MaxDirEnteries] of DirSearchEntry; { This holds all the directories specified to convert }
NumDirs: byte; { The number of directories used in above array }
SearchZips: boolean; { Search ZIP files for inclosed ARCs or PAKs }
AppendLog: boolean; { TRUE=Append to log FALSE=rewrite log file }
BatchMode: boolean; { TRUE=Don't wait for a keypress at beginning }
SuppressLog: boolean; { TRUE=Don't make a log file }
LogFile: text; { Log file handle, A2Z.LOG }
OldExitProc1: pointer; { Pointer to previous exit procedure routine. }
OldSeg,OldOfs: word; { Old segment and offset for interrupt 29h handler }
OldExitProc2: pointer; { Holder for old exit proc }
Reg: Registers; { Register storage for DOS calls }
CmdY: byte; { Line the cursor's on in the bottom window }
BufData: longint; { Pointer to the text buffer }
BufferSeg: word; { Segment of the text buffer }
BufferOfs: word; { Offset " " " " }
BufferPtr: pointer; { Pointer to the text buffer, in pointer format }
BufferLen: word; { Current length of text buffer }
NumFiles: word; { Number of files to convert }
NumBytes: longint; { Number of bytes to convert }
FileNum: word; { Current file number }
ConvertingInside: boolean; { TRUE=Converting internal arc files }
Saved: longint; { Total bytes saved so far }
TrickleUpError: boolean; { Error converting an internal file }
InternalCount: byte;
InterruptRequested: boolean;
WorkDir: string;
StatusFile: text;
StatusFileName: string;
function FileFound(F: ComStr): boolean;
{
This returns TRUE if the file F exists, FALSE otherwise. F can contain
wildcard characters.
}
var
SRec: SearchRec;
begin
SRec.Name := '*';
FindFirst(F,0,SRec);
if SRec.Name='*' then FileFound := false else FileFound := true;
end;
function ValidDir(D: string): boolean;
var
T: file;
begin
Assign(T, D+'VALID!!!.A2Z');
{$I-}
Rewrite(T);
{$I+}
if IOResult<>0 then ValidDir := false
else begin
Close(T);
Erase(T);
ValidDir := true;
end;
end;
procedure HaltWithMsg(M: string);
{
Displays the message in M to the user and halts program execution. Used
with critical errors.
}
begin
WriteLn(M);
Halt;
end;
procedure DisplayProgramHeader;
{
Display program version number and credits.
}
begin
WriteLn;
WriteLn('A2Z - ARC/PAK to ZIP converter');
WriteLn('version 1.6 by Ian McLean');
WriteLn;
end;
procedure InvokeConfiguration;
{
Configure A2Z by entering the paths for PKZIP, PKUNZIP, PKUNPAK, and PAK,
as well as a compression level for ASCII and binary files. This information
is then stored in the executable for A2Z for future use.
}
var
A: file of byte; { Temp variable for referencing A2Z.EXE }
L: longint; { Location of search }
MatchUp: byte; { Number of bytes currently matched }
C: char; { Character to match to }
begin
DisplayProgramHeader;
if not FileFound('A2Z.EXE') then
HaltWithMsg('A2Z.EXE must be in the current directory when invoking configuration.');
repeat
WriteLn;
WriteLn('Enter the name and path for PKWARE''s PKZIP.EXE. Please be sure to enter a');
WriteLn('path, filename, and extention:');
ReadLn(PKZIP);
until FileFound(PKZIP);
repeat
WriteLn;
WriteLn('Enter the name and path for PKWARE''s PKUNZIP.EXE. Again, please include a');
WriteLn('path, filename, and extention:');
ReadLn(PKUNZIP);
until FileFound(PKUNZIP);
repeat
WriteLn;
WriteLn('Enter the name and path for PKWARE''s PKUNPAK.EXE: (Do I need to remind you to');
WriteLn('include a path, name, and extention?)');
ReadLn(PKUNPAK);
until FileFound(PKUNPAK);
repeat
WriteLn;
WriteLn('If you have .PAK files to convert, enter the name and path for NoGate');
WriteLn('Consulting''s PAK.EXE; otherwise just press enter: (Don''t forget to');
WriteLn('include...)');
ReadLn(PAK);
until (PAK='') or FileFound(PAK);
WriteLn;
Write('Compression level for binary files: ');
repeat
repeat until KeyPressed;
BinaryLevel := ReadKey;
until BinaryLevel in ['1'..'4'];
WriteLn(BinaryLevel);
Write('Compression level for ASCII files: ');
repeat
repeat until KeyPressed;
AsciiLevel := ReadKey;
until AsciiLevel in ['1'..'4'];
WriteLn(AsciiLevel);
WriteLn;
Assign(A, 'A2Z.EXE'); { Configuration information is written to A2Z.EXE, }
Reset(A); { overlaying what was in the CONST block previously }
L := FileSize(A)-1; { Search starting at EOF, as constants are usually found there }
MatchUp := 10; { First character to match is the fifth of the string CONFIGNEXT }
repeat
Seek(A, L); { Read character from file }
Read(A, byte(C));
Dec(L); { Decrement counter (search backwards) }
case MatchUp of
10: if C=DataNext[MatchUp] then Dec(MatchUp); { If the character matches, we need to match the next one, otherwise we}
else if C=DataNext[MatchUp] then Dec(MatchUp) else MatchUp := 10; { need to match the tenth next (string wasn't correct)}
end;
until (MatchUp=0) or (L=0); { Repeat this until string found (Matchup=0) or we're at start of file }
if MatchUp<>0 then
HaltWithMsg('Unable to find configuration data area. Corrupted A2Z.EXE!');
Seek(A, L+12); { Seek the configuration information block }
for L := 0 to 321 do Write(A, Mem[seg(PKZIP):ofs(PKZIP)+L]); { Write the Directory/filenames and compression levels }
Close(A);
HaltWithMsg('A2Z is now configured for use.');
end;
{ End of procedure InvokeConfiguration }
procedure ShowInvokation;
{
Display program information and the invokation parameters for A2Z, then
halt the program.
}
begin
DisplayProgramHeader;
WriteLn('A2Z [/C] [/Z] [/A] [/B] [/S=device] [/W=dir] [filespec] [!filespec]');
WriteLn;
WriteLn('/C Invoke configuration');
WriteLn('/Z Search ZIP files for imbedded ARC/PAK files and process');
WriteLn('/A Append to log file, if it exists, instead of overwriting');
WriteLn('/B Batch mode. Don''t pause for a keypress at beginning');
WriteLn('/N Create no log file.');
WriteLn('/S=[device] Set the status display device (eg: /S=COM1). Default is NUL');
WriteLn('/W=[dir] Set the work directory to [dir]. Default is current directory or');
WriteLn(' value set by the environment variable A2ZWORK.');
WriteLn;
WriteLn('[filespec] Directory name or search specification of files to convert. If');
WriteLn(' there''s an ! before the name, subdirectories of the one specified');
WriteLn(' are searched. Up to twenty path names may be entered.');
WriteLn;
WriteLn('Examples:');
WriteLn('A2Z !C:\ !D:\ /Z Convert all dirs on drives C: and D:, search ZIPs');
WriteLn(' for imbedded ARC/PAKs');
WriteLn('A2Z FOOBAR.ARC Convert the file FOOBAR.ARC to a ZIP');
WriteLn('A2Z C:\*.PAK Convert all PAK files in dir C:\ to ZIPs');
Halt;
end;
procedure ReadCommandLine;
{
Read the parameters entered at the command line and build the list of
directories to convert. Check for configuration and show invokation if
necessary.
}
procedure ParseParameter(S: string);
{
Parse the parameter in S.
}
var
D: DirStr; { Temp holders for path name, etc }
N: NameStr;
E: ExtStr;
begin
if S[1]='/' then
case upcase(S[2]) of
'C': InvokeConfiguration;
'Z': SearchZips := true;
'A': AppendLog := true;
'B': BatchMode := true;
'N': SuppressLog := true;
'W': begin
if (length(S)<5) or (S[3]<>'=') then ShowInvokation;
WorkDir := copy(S,4,255);
end;
'S': begin
if (length(S)<4) or (S[3]<>'=') then ShowInvokation;
StatusFileName := copy(S,4,255);
end;
else ShowInvokation;
end
else begin
Inc(NumDirs);
with Dir[NumDirs] do
begin
if S[1]='!' then
begin
S := copy(S,2,255);
Below := true;
end
else Below := false;
if S[length(S)]<>'\' then
if (not FileFound(S)) and (FileFound(S+'\*.*')) then S := S+'\';
FSplit(FExpand(S), D,N,E);
if N='' then N := '*';
if (E='') or (E='.') then E := '.*';
Dir := D;
Name := N+E;
end;
end;
end;
var
L: byte; { Loop variable }
begin
SearchZips := false;
AppendLog := false;
BatchMode := false;
SuppressLog := false;
WorkDir := GetEnv('A2ZWORK');
StatusFileName := 'NUL';
NumDirs := 0;
if ParamCount=0 then ShowInvokation;
for L := 1 to ParamCount do ParseParameter(ParamStr(L));
if NumDirs=0 then ShowInvokation;
if WorkDir='' then GetDir(0,WorkDir);
WorkDir := FExpand(WorkDir);
if WorkDir[length(WorkDir)]<>'\' then WorkDir := WorkDir+'\';
if not ValidDir(WorkDir) then HaltWithMsg('Invalid work directory specified.');
Assign(StatusFile, StatusFileName);
{$I-}
Rewrite(StatusFile);
{$I+}
if IOResult<>0 then
begin
WriteLn('Unable to open specified status file.');
Assign(StatusFile, 'NUL');
Rewrite(StatusFile);
end
else WriteLn(StatusFile, 'A2Z v1.6 by Ian McLean');
end;
{ End of procedure ReadCommandLine }
procedure NewExitProc1;
{
This exit procedure closes the log file.
}
begin
if not SuppressLog then Close(LogFile);
Close(StatusFile);
ExitProc := OldExitProc1;
end;
procedure CheckSubPrograms;
begin
if PKZIP='UNCONFIGURED' then InvokeConfiguration;
if not (FileFound(PKZIP) and FileFound(PKUNZIP) and FileFound(PKUNPAK) and
(FileFound(PAK) or (PAK=''))) then
begin
WriteLn;
WriteLn('** Invalid program paths in configuration **');
InvokeConfiguration;
end;
end;
procedure OpenLogFile;
{
Open the file A2Z.LOG in the current directory. If it exists, append to it.
Place a date/time stamp on it, too, just for the heck of it. Also sets up
an exit procedure to close the file. If AppendLog is true, we'll append
to the log, otherwise we'll rewrite it.
}
function DateString: string;
{
Returns the current date in a string of the form: MON ## YEAR.
E.g, 21 Feb 1989 or 02 Jan 1988.
}
const
Month: array[1..12] of string[3]=
('Jan','Feb','Mar','Apr','May','Jun',
'Jul','Aug','Sep','Oct','Nov','Dec');
var
Y,M,D,Junk: word;
DS,YS: string[5];
begin
GetDate(Y,M,D,Junk);
Str(Y,YS);
Str(D,DS);
if length(DS)<2 then DS := '0'+DS;
DateString := DS+' '+Month[M]+' '+YS;
end;
function TimeString: string;
{
Returns the current time in the form: HH:MM am/pm
E.g, 12:00 am or 09:12 pm.
}
var
H,M,Junk: word;
HS,MS: string[5];
Am: boolean;
begin
GetTime(H,M,Junk,Junk);
case H of
0: begin
Am := true;
H := 12;
end;
1..11: Am := true;
12: Am := false;
else begin
Am := false;
H := H-12;
end;
end;
Str(H,HS);
Str(M,MS);
if length(HS)<2 then HS := '0'+HS;
if length(MS)<2 then MS := '0'+MS;
if Am then TimeString := HS+':'+MS+' am'
else TimeString := HS+':'+MS+' pm';
end;
begin
if not SuppressLog then
begin
Assign(LogFile, 'A2Z.LOG');
{$I-}
if AppendLog then Append(LogFile) else Rewrite(LogFile);
{$I+}
if IOResult<>0 then Rewrite(LogFile);
WriteLn(LogFile);
WriteLn(LogFile, DateString+' '+TimeString);
WriteLn(LogFile, '--------------------');
end;
OldExitProc1 := ExitProc;
ExitProc := @NewExitProc1;
end;
{ End procedure OpenLogFile }
procedure LogError(E: string);
{
Write the message in string E to the screen and to the log file.
}
begin
WriteLn(E);
if not SuppressLog then WriteLn(LogFile, E);
end;
procedure WriteStatus(M: string);
begin
Write(StatusFile,M);
end;
procedure WriteLnStatus(M: string);
{
Write the message in M to the status device, with linefeed.
}
begin
WriteLn(StatusFile,M);
end;
(********* The following search engine routines are sneakly swiped *********)
(********* from Turbo Technix v1n6. See there for further details *********)
type
ProcType= procedure(var S: SearchRec; P: PathStr);
var
EngineMask: FullNameStr;
EngineAttr: byte;
EngineProc: ProcType;
EngineCode: byte;
function ValidExtention(var S: SearchRec): boolean;
var
Junk: string;
E: ExtStr;
begin
if S.Attr and Directory=Directory then
begin
ValidExtention := true;
exit;
end;
FSplit(S.Name,Junk,Junk,E);
if (E='.ARC') or (E='.PAK') or (SearchZips and (E='.ZIP')) then
ValidExtention := true else ValidExtention := false;
end;
procedure SearchEngine(Mask: PathStr; Attr: byte; Proc: ProcType;
var ErrorCode: byte);
var
S: SearchRec;
P: PathStr;
Ext: ExtStr;
begin
FSplit(Mask, P, Mask, Ext);
Mask := Mask+Ext;
FindFirst(P+Mask,Attr,S);
if DosError<>0 then
begin
ErrorCode := DosError;
exit;
end;
while DosError=0 do
begin
if ValidExtention(S) then Proc(S, P);
FindNext(S);
end;
if DosError=18 then ErrorCode := 0
else ErrorCode := DosError;
end;
function GoodDirectory(S: SearchRec): boolean;
begin
GoodDirectory := (S.name<>'.') and (S.Name<>'..') and
(S.Attr and Directory=Directory);
end;
procedure SearchOneDir(var S: SearchRec; P: PathStr);
begin
if GoodDirectory(S) then
begin
P := P+S.Name;
SearchEngine(P+'\'+EngineMask,EngineAttr,EngineProc,EngineCode);
SearchEngine(P+'\*.*',Directory or Archive, SearchOneDir,EngineCode);
end;
end;
procedure SearchEngineAll(Path: PathStr; Mask: FullNameStr; Attr: byte;
Proc: ProcType; var ErrorCode: byte);
begin
EngineMask := Mask;
EngineProc := Proc;
EngineAttr := Attr;
SearchEngine(Path+Mask,Attr,Proc,ErrorCode);
SearchEngine(Path+'*.*',Directory or Archive,SearchOneDir,ErrorCode);
ErrorCode := EngineCode;
end;
(************** Thus ends the sneakly swiped code *************)
(**** We now return you to our regularly scheduled program ****)
procedure AddToEstimate(var S: SearchRec; P: PathStr);
{
Called by the search engine, adds the information in S to the file estimates
NumFiles and NumBytes. Displays the filename temporaraly, too.
}
var
X: byte;
begin
Inc(NumFiles);
Inc(NumBytes,S.Size);
X := WhereX;
ClrEol;
Write(S.Name);
GotoXY(X,WhereY);
end;
procedure GetFileEstimates;
{
Estimate the number of bytes and number of files to convert.
}
var
L: byte;
ErrorCode: byte;
begin
DisplayProgramHeader;
WriteLn('Searching directories...');
WriteLn;
NumFiles := 0;
NumBytes := 0;
for L := 1 to NumDirs do
with Dir[L] do
begin
Write(Dir);
if Below then SearchEngineAll(Dir,Name,Archive,AddToEstimate,ErrorCode)
else SearchEngine(Dir+Name,Archive,AddToEstimate,ErrorCode);
ClrEol;
WriteLn;
end;
WriteLn;
Write(NumBytes,' bytes in ',NumFiles,' file(s) to ');
if SearchZips then WriteLn('convert/examine.')
else WriteLn('convert.');
WriteLn;
if NumFiles=0 then HaltWithMsg('No files to convert!');
if not BatchMode then
begin
WriteLn('Press any key...');
repeat until KeyPressed;
end;
while KeyPressed do char(L) := ReadKey;
end;
{ End of procedure GetFileEstimates }
procedure IPP;
{ Interrupt pre-processor. This is a new handler for interrupt 29h which
provides special functions. See comments in IHAND.ASM}
interrupt;
begin
InLine(
$06/ { push es }
$1E/ { push ds }
$53/ { push bx }
$57/ { push di }
$BB/$3F/$3F/ { mov bx, 3f3fh }
$8E/$C3/ { mov es, bx }
$BB/$3F/$3F/ { mov bx, 3f3fh }
$26/$8B/$3F/ { mov di, word ptr [es:bx] }
$26/$8E/$5F/$02/ { mov ds, word ptr [es:bx+2] }
$88/$05/ { mov byte ptr [di], al }
$26/$FF/$07/ { inc word ptr [es:bx] }
$5F/ { pop di }
$5B/ { pop bx }
$1F/ { pop ds }
$07/ { pop es }
$3C/$0A/ { cmp al, 10 }
$75/$28/ { jne looper }
$50/ { push ax }
$52/ { push dx }
$51/ { push cx }
$53/ { push bx }
$B4/$03/ { mov ah, 3 }
$B7/$00/ { mov bh, 0 }
$CD/$10/ { int 10h }
$80/$FE/$18/ { cmp dh, 24 }
$75/$15/ { jne popper }
$FE/$CE/ { dec dh }
$B7/$00/ { mov bh, 0 }
$B4/$02/ { mov ah, 2 }
$CD/$10/ { int 10h }
$B8/$01/$06/ { mov ax, 0601h }
$B7/$07/ { mov bh, 7 }
$B9/$00/$11/ { mov cx, 1100h }
$BA/$4F/$18/ { mov dx, 184fh }
$CD/$10/ { int 10h }
$5B/ { popper: pop bx }
$59/ { pop cx }
$5A/ { pop dx }
$58/ { pop ax }
$9C/ { looper: pushf }
$9A/$00/$00/$00/$00/ { call far [0:0] }
$CF); { iret }
end;
procedure NewExitProc2;
{ This exit procedure removes the interrupt 29h handler from memory and places
the cursor at the bottom of the screen. }
begin
Reg.AH := $25;
Reg.AL := $29;
Reg.DS := OldSeg;
Reg.DX := OldOfs;
MsDos(Reg);
Window(1,1,80,25);
GotoXY(1,24);
TextAttr := $07;
ClrEol;
WriteLn('Thank you for using A2Z!');
ExitProc := OldExitProc2;
end;
procedure ResetBuffer;
{ Reset pointers to the text buffer, effectivly deleting any text in it }
begin
MemW[seg(BufData):ofs(BufData)] := BufferOfs; { Set first 2 bytes of BufData to point to buffer offset }
MemW[seg(BufData):ofs(BufData)+2] := BufferSeg; { And next two bytes to point to buffer segment }
MemW[seg(IPP):ofs(IPP)+21] := seg(BufData); { Now point the interrupt routine to BufData for pointer }
MemW[seg(IPP):ofs(IPP)+26] := ofs(BufData); { to the text buffer }
end;
function BufSize: word;
{ This returns the number of characters in the text buffer. It's what BufData
now points to minus what is origionally pointed to, eg, the number of times
IPP incremented it }
begin
BufSize := MemW[seg(BufData):ofs(BufData)]-BufferOfs;
end;
function InBuffer(S: string): integer;
{ This searched the text buffer for the string S, and if it's found returns
the offset in the buffer. If it's not found a -1 is returned }
var
L,M: word;
X: byte;
begin
X := 1;
L := BufferOfs;
M := BufSize;
while (X<=length(S)) and (L<=M) do
begin
if Mem[BufferSeg:L]=byte(S[X]) then Inc(X) else X := 1;
Inc(L);
end;
if X>length(S) then InBuffer := L-length(S) else InBuffer := -1;
end;
procedure InstallInterruptHandler;
{ Installs the int 29h handler }
begin
BufferLen := $4000; { Set up a 16k buffer }
GetMem(BufferPtr,BufferLen); { Allocate memory pointed at by BufferPtr }
BufferSeg := seg(BufferPtr^); { Read segment and offset of buffer for easy access }
BufferOfs := ofs(BufferPtr^);
ResetBuffer; { Place these values in the IPP routine, resetting buffer }
Reg.AH := $35;
Reg.AL := $29; { DOS service 35h, get interrupt vector for 29h }
MsDos(Reg);
OldSeg := Reg.ES; { Store the segment and offset of the old vector for later use }
OldOfs := Reg.BX;
MemW[seg(IPP):ofs(IPP)+90] := Reg.BX; { And store them so IPP can call the routine }
MemW[seg(IPP):ofs(IPP)+92] := Reg.ES;
Reg.AL := $29; { DOS service 25h, set interrupt vector 29h }
Reg.AH := $25;
Reg.DS := seg(IPP); { Store segment and offset for IPP. The +16 is to skip TP stack }
Reg.DX := ofs(IPP)+16; { maintainence routines }
MsDos(Reg);
OldExitProc2 := ExitProc; { Set up new exit procedure to remove routine at program termination }
ExitProc := @NewExitProc2;
TextAttr := $07; { Clear the screen to white on black }
ClrScr;
GotoXY(1,15); { Go to line 15 and 16 and draw an inverse bar which will show the }
TextAttr := $70; { current command being executed. }
Write('DOS COMMAND:');
ClrEol;
WriteLn;
ClrEol;
TextAttr := $07; { Set text color back to white on black }
Window(1,1,80,13); { Make active window at top of screen and home cursor }
GotoXY(1,1);
CmdY := 18; { Assume the cursor in the lower window's at the top of window }
end;
procedure ExecCommand(Cmd,Parm: string);
{ Executes the command in Cmd with command line parameters in Parm. This is
executed in the lower window }
var
OX,OY: byte; { Upper window X and Y }
begin
ResetBuffer; { Clear text buffer }
OX := WhereX; { Store upper window X and Y }
OY := WhereY;
Window(1,1,80,25); { Make entire screen active window }
GotoXY(14,15); { Go to line 14 (COMMAND bar) }
TextAttr := $70;
Write(Cmd,' ',Parm); { Write the command and parameters in inverse }
GotoXY(1,CmdY); { Go to location in bottom window }
TextAttr := $07; { Normal text color }
Exec(Cmd,Parm); { Execute command }
CmdY := WhereY; { Store new Y location }
GotoXY(14,15);
TextAttr := $70; { Erase the COMMAND bar }
ClrEol;
WriteLn;
ClrEol;
TextAttr := $07;
Window(1,1,80,13); { Reset the upper window }
GotoXY(OX,OY); { Re-position cursor }
end;
function ArchiveBad: boolean;
{
Returns true if there are any text strings in the buffer that would
indicate a bad archive
}
begin
if (InBuffer('error in')<>-1) or (InBuffer('Insufficent Memory')<>-1) or
(InBuffer('Disk full')<>-1) or (InBuffer('Unknown comp')<>-1) or
(InBuffer('CRC check')<>-1) or (InBuffer('run-time')<>-1) then
ArchiveBad := true else ArchiveBad := false;
end;
function PakBad: boolean;
{
Returns true if there are any PAK errors in the buffer.
}
begin
if (InBuffer('Could not open')<>-1) or (InBuffer('Unknown')<>-1) or
(InBuffer('CRC ')<>-1) or (InBuffer('Unable')<>-1) then
PakBad := true else PakBad := false;
end;
function ZipBad: boolean;
{
Same as above two routines, except that this checks the output that PKZIP
would have made
}
begin
if (InBuffer('can''t create')<>-1) or (InBuffer('disk full')<>-1) or
(InBuffer('memory ')<>-1) or (InBuffer('run-time')<>-1) then
ZipBad := true else ZipBad := false;
end;
function InternalInZip: boolean;
begin
if (InBuffer('.ARC')<>-1) or (InBuffer('.PAK')<>-1) or
(InBuffer('.ZIP'#13#10' ')<>-1) or
(InBuffer('.ZIP'#13#10'-')<>-1) then InternalInZip := true else
InternalInZip := false;
end;
function ZipViewBad: boolean;
begin
if (InBuffer('memory ')<>-1) or (InBuffer('run-time')<>-1) or
(InBuffer('ZipRecover')<>-1) or (InBuffer('I don''t')<>-1) or
(InBuffer('inconsistant local')<>-1) then ZipViewBad := true
else ZipViewBad := false;
end;
function UnZipBad: boolean;
begin
if ZipBad or
(InBuffer('Warning!')<>-1) or (InBuffer('can''t')<>-1) or
(InBuffer('in ZIP')<>-1) then UnZipBad := true
else UnZipBad := false;
end;
var
X: integer;
L: string[60];
C: string[10];
Code: integer;
Okay: boolean;
T: text;
SRec: SearchRec;
Z: ComStr;
EC: byte;
RC: char;
CurWork: string;
procedure Convert(var S: SearchRec; P: PathStr);
procedure Indent;
var
L: byte;
begin
for L := 1 to InternalCount do Write(' ');
end;
procedure ArchiveError(N: string);
{
Report an archive error if we're working with the top file, otherwise
set an error flag.
}
begin
if ConvertingInside then
begin
Indent;
WriteLn(N);
TrickleUpError := true;
end
else LogError(N);
end;
procedure DeleteDir(P: string);
{
Delete all files in the directory named and remove it.
}
var
SRec: SearchRec;
ErrorCode: byte;
begin
FindFirst(P+'\*.*',0,SRec);
while DosError=0 do
begin
Assign(T, P+'\'+SRec.Name);
{$I-}
Erase(T);
{$I+}
ErrorCode := IOResult;
FindNext(SRec);
end;
{$I-}
RmDir(P);
{$I+}
ErrorCode := IOResult;
end;
procedure CopyFile(SourceName,DestName: ComStr);
var
Source,Dest: file;
RecsRead: word;
Buffer: pointer;
BufSize: word;
T: longint;
begin
if MaxAvail>65535 then BufSize := 65535 else BufSize := MaxAvail;
BufSize := BufSize div 1024;
GetMem(Buffer, BufSize*1024);
Assign(Source, SourceName);
Reset(Source,1024);
Assign(Dest,DestName);
Rewrite(Dest,1024);
for T := 1 to FileSize(Source) do
begin
BlockRead(Source,Buffer^,BufSize,RecsRead);
BlockWrite(Dest,Buffer^,RecsRead);
end;
T := FileSize(Source)*1024;
Reset(Source,1);
Reset(Dest,1);
Seek(Source,T);
Seek(Dest,T);
repeat
BlockRead(Source,Buffer^,BufSize*1024,RecsRead);
BlockWrite(Dest,Buffer^,RecsRead);
until RecsRead=0;
GetFTime(Source, T);
SetFTime(Dest, T);
Close(Source);
Close(Dest);
FreeMem(Buffer, BufSize*1024);
Erase(Source);
end;
function IndentSpaces: string;
var
S: string;
L: byte;
begin
S := '';
for L := 1 to InternalCount do S := S+' ';
IndentSpaces := S;
end;
var
N: NameStr;
E: ExtStr;
ArcComment: string[50];
FilesInArc: word;
UnArcedSize: longint;
ArcedSize: longint;
OCI: boolean;
begin
if TrickleUpError then exit;
if KeyPressed then
begin
RC := ReadKey;
if RC=#27 then
begin
if ConvertingInside then
begin
TrickleUpError := true;
InterruptRequested := true;
exit;
end
else begin
LogError('*** Conversion interrupted ***');
WriteLnStatus('**** Conversion interrupted ***');
Halt;
end;
end;
end;
FSplit(P+S.Name,P,N,E);
WriteLnStatus(IndentSpaces+'Converting '+S.Name);
if not ConvertingInside then
begin
Inc(FileNum);
WriteLn;
WriteLnStatus('');
TextAttr := $0F;
WriteLn('Converting ',P+S.Name,' Saved: ',Saved,' bytes File: ',FileNum,' of ',NumFiles);
TextAttr := $07;
end
else begin
Indent;
TextAttr := $0F;
WriteLn('Converting internal file ',N,E);
WriteLnStatus(IndentSpaces+'Converting internal file '+N+E);
TextAttr := $07;
end;
if E='.ZIP' then
begin
Indent;
Write('Checking ',N,E,' for internal files...');
WriteStatus(IndentSpaces+'Checking '+S.Name+' for internal files...');
ExecCommand(PKZIP,'/V '+P+N);
if ZipViewBad then
begin
WriteLn;
ArchiveError('Error in ZIPfile '+P+N+E+'; file skipped.');
WriteLnStatus(' Error in ZIPfile; file skipped.');
exit;
end;
ArcedSize := S.Size;
if InternalInZIP then
begin
WriteLn(' found.');
WriteLnStatus(' found.');
X := InBuffer('Searching');
if X=-1 then
begin
ArchiveError('Error in Zipfile '+P+N+E+'; file skipped.');
WriteLnStatus(IndentSpaces+'Error in Zipfile '+N+E+'; file skipped.');
exit;
end;
ArcComment := '';
X := X+15;
repeat
Inc(X);
until char(Mem[BufferSeg:X]) in [' ',#13,#10];
if char(Mem[BufferSeg:X])=' ' then
begin
repeat
Inc(X);
until char(Mem[BufferSeg:X])=' ';
Inc(X);
repeat
ArcComment := ArcComment+char(Mem[BufferSeg:X]);
Inc(X);
until char(Mem[BufferSeg:X]) in [#10,#13];
end;
while ArcComment[length(ArcComment)]=' ' do Dec(ArcComment[0]);
L := '';
X := InBuffer('--------'+#13+#10);
if X=-1 then
begin
ArchiveError('Error in Zipfile '+P+N+E+'; file skipped.');
WriteLnStatus(IndentSpaces+'Error in Zipfile '+N+E+'; file skipped.');
exit;
end;
repeat
Inc(X);
until char(Mem[BufferSeg:X]) in ['0'..'9'];
repeat
L := L+char(Mem[BufferSeg:X]);
Inc(X);
until char(Mem[BufferSeg:X]) in [#10,#13];
C := '';
repeat
C := C+L[1];
L := copy(L,2,255);
until L[1]=' ';
while L[1]=' ' do L := copy(L,2,255);
Val(C,UnarcedSize,Code);
C := '';
repeat
C := C+L[1];
L := copy(L,2,255);
until L[1]=' ';
while L[1]=' ' do L := copy(L,2,255);
while L[1]<>' ' do L := copy(L,2,255);
while L[1]=' ' do L := copy(L,2,255);
Val(C,ArcedSize,Code);
Val(L,FilesInArc,Code);
Indent;
ArcedSize := S.Size;
WriteLn(FilesInArc,' files(s), ',ArcedSize,' bytes zipped, ',UnArcedSize,' bytes unzipped');
Str(FilesInArc,Z);
Str(ArcedSize,L);
Str(UnarcedSize,C);
WriteLnStatus(IndentSpaces+Z+' file(s), '+L+' bytes zipped, '+C+' bytes unzipped');
if ArcComment<>'' then
begin
Indent;
WriteLn('Zipfile comment: "',ArcComment,'"');
WriteLnStatus(IndentSpaces+'Zipfile comment: "'+ArcComment+'"');
end;
Indent;
Write('Unzipping ',N,E,'...');
WriteStatus(IndentSpaces+'Unzipping '+N+E+'...');
CurWork := CurWork+'\A2Z.$$$';
MkDir(CurWork);
ExecCommand(PKUNZIP,P+N+' '+CurWork);
if UnZipBad then
begin
DeleteDir(CurWork);
Dec(CurWork[0],8);
WriteLn;
ArchiveError('Error unzipping '+P+N+E+'; file skipped.');
WriteLnStatus('');
WriteLnStatus(IndentSpaces+'Error unzipping '+N+E+'; file skipped.');
exit;
end;
WriteLn(' done.');
WriteLnStatus(' done.');
end
else
begin
WriteLn(' none found.');
WriteLnStatus(' none found.');
ArchiveError(N+E+' did not need to be modified.');
WriteLnStatus(IndentSpaces+N+E+' did not need to be modified.');
TrickleUpError := false;
exit;
end;
end
else begin
Indent;
Write('Analyzing ',N,E,'...');
WriteStatus(IndentSpaces+'Analyzing '+N+E+'...');
ExecCommand(PKUNPAK,'-V '+P+N+E);
WriteLn(' done.');
WriteLnStatus(' done.');
if ArchiveBad then
begin
ArchiveError('Error in archive '+P+N+E+'; file skipped.');
WriteLnStatus(IndentSpaces+'Error in archive; file skipped.');
exit;
end;
X := InBuffer('Searching');
if X=-1 then
begin
ArchiveError('Error in archive '+P+N+E+'; file skipped.');
WriteLnStatus(IndentSpaces+'Error in archive; file skipped.');
exit;
end;
ArcComment := '';
X := X+11;
repeat
Inc(X);
until char(Mem[BufferSeg:X]) in [' ',#13,#10];
if char(Mem[BufferSeg:X])=' ' then
begin
repeat
Inc(X);
until char(Mem[BufferSeg:X])=' ';
Inc(X);
repeat
ArcComment := ArcComment+char(Mem[BufferSeg:X]);
Inc(X);
until char(Mem[BufferSeg:X]) in [#10,#13];
end;
while ArcComment[length(ArcComment)]=' ' do Dec(ArcComment[0]);
L := '';
X := InBuffer(#13+#10+'---- ');
if X=-1 then
begin
ArchiveError('Error in archive '+P+N+E+'; file skipped.');
WriteLnStatus(IndentSpaces+'Error in archive; file skipped.');
exit;
end;
X := X+52;
repeat
L := L+char(Mem[BufferSeg:X]);
Inc(X);
until char(Mem[BufferSeg:X]) in [#10,#13];
C := '';
repeat
C := C+L[1];
L := copy(L,2,255);
until L[1]=' ';
while L[1]=' ' do L := copy(L,2,255);
Val(C,FilesInArc,Code);
C := '';
repeat
C := C+L[1];
L := copy(L,2,255);
until L[1]=' ';
while L[1]=' ' do L := copy(L,2,255);
Val(C,UnArcedSize,Code);
C := '';
repeat
C := C+L[1];
L := copy(L,2,255);
until L[1] in [#13,#10,#32];
Val(C,ArcedSize,Code);
Indent;
WriteLn(FilesInArc,' files(s), ',ArcedSize,' bytes arced, ',UnArcedSize,' bytes unarced');
Str(FilesInArc,Z);
Str(ArcedSize,L);
Str(UnarcedSize,C);
WriteLnStatus(IndentSpaces+Z+' file(s), '+L+' bytes arced, '+C+' bytes unarced');
if ArcComment<>'' then
begin
Indent;
WriteLn('Archive comment: "',ArcComment,'"');
WriteLnStatus(IndentSpaces+'Archive comment: "'+ArcComment+'"');
end;
Indent;
Write('Extracting files...');
WriteStatus(IndentSpaces+'Extracting files...');
CurWork := CurWork+'\A2Z.$$$';
MkDir(CurWork);
if E='.ARC' then
begin
ExecCommand(PKUNPAK,P+N+' '+CurWork);
Okay := not ArchiveBad;
end;
if E='.PAK' then
begin
ExecCommand(PAK,'e '+P+N+' '+CurWork);
Okay := not PakBad;
end;
WriteLn(' done.');
if not Okay then
begin
ArchiveError('Error extracting '+P+N+E+'; skipping.');
WriteLnStatus(IndentSpaces+'Error extracting archive; skipping.');
DeleteDir(CurWork);
Dec(CurWork[0],8);
exit;
end;
end;
Indent;
WriteLn('Checking internal files...');
WriteLnStatus(IndentSpaces+'Checking internal files...');
OCI := ConvertingInside;
ConvertingInside := true;
Inc(InternalCount);
SearchEngine(CurWork+'\*.*',Archive,Convert,EC);
Dec(InternalCount);
ConvertingInside := OCI;
if TrickleUpError then
begin
if InterruptRequested then
begin
DeleteDir(CurWork);
Dec(CurWork[0],8);
if ConvertingInside then exit;
LogError('*** Conversion interrupted ***');
WriteLnStatus('*** Conversion interrupted ***');
Halt;
end;
if not ConvertingInside then
begin
TrickleUpError := false;
LogError('Unable to convert '+P+N+E+' due to an internal file error.');
WriteLnStatus(IndentSpaces+'Unable to convert '+N+E+' due to an internal file error.');
end;
DeleteDir(CurWork);
Dec(CurWork[0],8);
exit;
end;
CopyFile(P+N+E,P+N+'.A2B');
Indent;
Write('Creating ZIP file ',N,'.ZIP...');
WriteStatus(IndentSpaces+'Creating ZIP file '+N+'.ZIP...');
Z := P+N+'.ZIP';
Assign(T, Z);
{$I-}
Erase(T);
{$I+}
Code := IOResult;
if ArcComment='' then
ExecCommand(PKZIP,Z+' -ea'+AsciiLevel+' -eb'+BinaryLevel+' '+
CurWork+'\*.*')
else
begin
Assign(T, WorkDir+'ZCOMMENT.A2Z');
Rewrite(T);
WriteLn(T, ArcComment);
Close(T);
Reg.BX := 0;
Reg.AH := $45;
MsDos(Reg);
Code := Reg.AX;
Reset(T);
Reg.BX := TextRec(T).Handle;
Reg.CX := 0;
Reg.AH := $46;
MsDos(Reg);
ExecCommand(PKZIP,Z+' -ea'+AsciiLevel+' -eb'+BinaryLevel+' -a '+CurWork+'\*.* -z');
Reg.BX := Code;
Reg.CX := 0;
Reg.AH := $46;
MsDos(Reg);
Reg.BX := Code;
Reg.AH := $3E;
MsDos(Reg);
Close(T);
Erase(T);
end;
WriteLn(' done.');
WriteLnStatus(' done.');
if ZipBad then
begin
ArchiveError('Unable to create zip file: '+Z+'; file skipped.');
WriteLnStatus(IndentSpaces+'Unable to create zip file; file skipped');
DeleteDir(CurWork);
Dec(CurWork[0],8);
CopyFile(P+N+'.A2B',P+N+E);
exit;
end;
FindFirst(Z,0,SRec);
Assign(T, P+N+'.A2B');
{$I-}
Erase(T);
{$I+}
Code := IOResult;
if not ConvertingInside then Saved := Saved+(ArcedSize-SRec.Size);
Assign(T, Z);
Reset(T);
SetFTime(T, S.Time);
Close(T);
Str(ArcedSize-SRec.Size,C);
if ConvertingInside then
begin
Indent;
WriteLn('Internal file '+N+E+' converted.');
WriteLnStatus(IndentSpaces+'Internal file '+N+E+' converted.');
end
else
if E='.ZIP' then
begin
LogError(P+N+E+' internally converted to ZIP, '+C+' bytes saved.');
WriteLnStatus(N+E+' internally converted to ZIP, '+C+' bytes saved.');
end
else begin
LogError('File '+P+N+E+' converted to ZIP, '+C+' bytes saved.');
WriteLnStatus('File '+N+E+' converted to ZIP, '+C+' bytes saved.');
end;
DeleteDir(CurWork);
Dec(CurWork[0],8);
end;
procedure ConvertFiles;
{
This is the main conversion loop of the program. It will call the convert
arc routine from the search engine.
}
var
L: byte;
ErrorCode: byte;
begin
FileNum := 0;
ConvertingInside := false;
InternalCount := 0;
InterruptRequested := false;
Saved := 0;
TrickleUpError := false;
CurWork := copy(WorkDir,1,length(WorkDir)-1);
for L := 1 to NumDirs do
with Dir[L] do
if Below then SearchEngineAll(Dir,Name,Archive,Convert,ErrorCode)
else SearchEngine(Dir+Name,Archive,Convert,ErrorCode);
end;
procedure SummarizeLog;
var
S: string[30];
begin
Str(Saved, S);
LogError(S+' bytes saved total.');
end;
begin
ReadCommandLine;
CheckSubPrograms;
OpenLogFile;
GetFileEstimates;
CheckBreak := false;
InstallInterruptHandler;
ConvertFiles;
SummarizeLog;
end.